home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / PROCOM.f < prev    next >
Text File  |  1992-07-31  |  8KB  |  218 lines
  1.       SUBROUTINE PROCOM 
  2. *-----------------------------------------------------------------------
  3. *   
  4. *   Processes common blocks: collects name lists,   
  5. *   marks the variables referenced in each routine  
  6. *   
  7. *-----------------------------------------------------------------------
  8.       include 'PARAM.h' 
  9.       include 'ALCAZA.h' 
  10.       include 'CLASS.h' 
  11.       include 'FLAGS.h' 
  12.       include 'CURSTA.h' 
  13.       include 'FLWORK.h' 
  14.       include 'STATE.h' 
  15.       LOGICAL RANGE 
  16.       CHARACTER SCB*8   
  17. *--- get external statement number  
  18.       ICLE=ISTMDS(6,ICURCL(1))  
  19.       IF(ICLE.EQ.12)  THEN  
  20. *--- common block   
  21.          IV=0   
  22.          ICOMMB=ISTMDS(17,ICURCL(1))
  23.          ICOMMV=ISTMDS(21,ICURCL(1))
  24.    10    CONTINUE   
  25. *--- find c.b. name, and first and last variable in this c.b.   
  26.          IF(ITBIT(NAMTYP(ISNAME+IV+1),ICOMMB).EQ.0) THEN
  27. *--- first name not c.b. name ---> blank common 
  28.             SCB='BLANKCOM'  
  29.          ELSE   
  30.             SCB=SNAMES(ISNAME+IV+1) 
  31.             IV=IV+1 
  32.          ENDIF  
  33. *--- last var. in this c.b. is min. pos. of '//', or c.b. name  
  34.          IPT=NSSTRT(IV+1)-1 
  35.          INS=INDEX(SSTA(IPT+1:NCHST),'//')  
  36.          IND=INDEX(SSTA(IPT+1:NCHST),'/ /') 
  37.          IF(IND.GT.0) THEN  
  38.             IF(INS.GT.0) THEN   
  39.                INS=MIN(IND,INS) 
  40.             ELSE
  41.                INS=IND  
  42.             ENDIF   
  43.          ENDIF  
  44.          IF(INS.GT.0) THEN  
  45.             INS=IPT+INS 
  46.          ELSE   
  47.             INS=NCHST+1 
  48.          ENDIF  
  49. *--- collect variable name ref.s in IWS 
  50.          N=0
  51.          ILOW=IV+1  
  52.          DO 20 I=ILOW,NSNAME
  53.             K=ISNAME+I  
  54.             NT=NAMTYP(K)
  55.             IF(ITBIT(NT,ICOMMB).NE.0) GOTO 30   
  56.             IF(NSSTRT(I).GT.INS) GOTO 30
  57.             IF(ITBIT(NT,ICOMMV).NE.0) THEN  
  58.                IF(NCBVAR+N.EQ.MXNAME) GOTO 180  
  59.                N=N+1
  60.                SCBVAR(NCBVAR+N)=SNAMES(K)   
  61.             ENDIF   
  62.             IV=I
  63.    20    CONTINUE   
  64.    30    CONTINUE   
  65. *--- store in name list for this common block   
  66.          IF(N.GT.0) THEN
  67.             CALL LSORT(SCBVAR(NCBVAR+1),IWS,.FALSE.,N)  
  68. *--- look for name in c.b. name table   
  69.             CALL NAMSRC(SCB,SCBNAM,NCBNAM,IPOS,LAST)
  70.             IF(IPOS.EQ.0) THEN  
  71. *--- not in table - add to existing 
  72.                IF(NCBNAM.EQ.MAXGRP) GOTO 190
  73.                DO 40 I=NCBNAM,LAST+1,-1 
  74.                   SCBNAM(I+1)=SCBNAM(I) 
  75.                   NCBGRP(I+1)=NCBGRP(I) 
  76.                   KCBGRP(I+1)=KCBGRP(I) 
  77.    40          CONTINUE 
  78.                NCBNAM=NCBNAM+1  
  79.                SCBNAM(LAST+1)=SCB   
  80.                NCBGRP(LAST+1)=N 
  81.                KCBGRP(LAST+1)=NCBVAR
  82.             ELSE
  83. *--- already in table - add in place, and merge 
  84.                CALL NAMOVE(SCBVAR,KCBGRP(IPOS)+NCBGRP(IPOS),NCBVAR,N)   
  85.                CALL LMERGE(SCBVAR,IWS,.FALSE.,KCBGRP(IPOS),NCBGRP(IPOS),
  86.      +         N)   
  87.                DO 50 I=1,NCBNAM 
  88.                   IF(KCBGRP(I).GT.KCBGRP(IPOS)) KCBGRP(I)=KCBGRP(I)+N   
  89.    50          CONTINUE 
  90.                DO 60 I=1,NEQNAM 
  91.                   IF(KEQGRP(I).GT.KCBGRP(IPOS)) KEQGRP(I)=KEQGRP(I)+N   
  92.    60          CONTINUE 
  93.                NCBGRP(IPOS)=NCBGRP(IPOS)+N  
  94.             ENDIF   
  95.             NCBVAR=NCBVAR+N 
  96.          ENDIF  
  97.          IF(IV.LT.NSNAME) GOTO 10   
  98.       ELSEIF(ICLE.EQ.30)  THEN  
  99. *--- EQUIVALENCE
  100.          IV=0   
  101.          IPT=0  
  102.    70    CONTINUE   
  103.          ILB=INDEX(SSTA(IPT+1:NCHST),'(')   
  104.          IF(ILB.GT.0) THEN  
  105.             ILB=ILB+IPT 
  106.             CALL SKIPLV(SSTA,ILB+1,NCHST,.FALSE.,IRB,ILEV)  
  107.             IF(IRB.GT.0) THEN   
  108.                IPT=IRB  
  109. *--- only names outside brackets (inside each group)
  110.                CALL GETRNG(ILB+1,IRB-1,IWS) 
  111.                ILOW=IV+1
  112.                N=0  
  113.                DO 80 I=ILOW,NSNAME  
  114.                   IF(NSSTRT(I).GT.IRB) GOTO 90  
  115.                   IF(.NOT.RANGE(NSSTRT(I),IWS)) THEN
  116.                      IF(NCBVAR+N.EQ.MXNAME) GOTO 180
  117.                      N=N+1  
  118.                      SCBVAR(NCBVAR+N)=SNAMES(ISNAME+I)  
  119.                   ENDIF 
  120.                   IV=I  
  121.    80          CONTINUE 
  122.    90          CONTINUE 
  123.                IF(N.GT.0) THEN  
  124.                   IF(NEQNAM.EQ.MAXGRP) GOTO 200 
  125.                   CALL LSORT(SCBVAR(NCBVAR+1),IWS,.FALSE.,N)
  126.                   NEQNAM=NEQNAM+1   
  127.                   KEQGRP(NEQNAM)=NCBVAR 
  128.                   NEQGRP(NEQNAM)=N  
  129.                   NCBVAR=NCBVAR+N   
  130.                ENDIF
  131.                IF(IPT.LT.NCHST) GOTO 70 
  132.             ENDIF   
  133.          ENDIF  
  134.       ELSEIF(ICLE.EQ.16.OR.ISTMDS(11,ICURCL(1)).EQ.1)  THEN 
  135. *--- DATA statement, or executable, i.e. start of routine   
  136.          IF(.NOT.STATUS(13)) THEN   
  137. *--- merge all equiv. groups with common blocks 
  138.             STATUS(13)=.TRUE.   
  139.   100       CONTINUE
  140.             DO 150 IE=1,NEQNAM  
  141.                KEQ=KEQGRP(IE)   
  142.                NEQ=NEQGRP(IE)   
  143.                DO 140 IEI=1,NEQ 
  144.                   DO 130 IC=1,NCBNAM
  145.                      CALL NAMSRC(SCBVAR(KEQGRP(IE)+IEI),SCBVAR(KCBGRP   
  146.      +               (IC)+1), NCBGRP(IC),IPOS,LAST) 
  147.                      IF(IPOS.NE.0) THEN 
  148. *--- equiv. group var. is in this c.b., add complete group  
  149.                         CALL NAMOVE(SCBVAR,KCBGRP(IC)+NCBGRP(IC),KEQ,   
  150.      +                  NEQ)
  151.                         KCB=KCBGRP(IC)  
  152.                         DO 110 I=1,NCBNAM   
  153.                            IF(KEQ.LT.KCB) THEN  
  154.                               IF(KCBGRP(I).LE.KCB.AND.KCBGRP(I).GT.KEQ) 
  155.      +                        KCBGRP(I)=KCBGRP(I)-NEQ   
  156.                            ELSE 
  157.                               IF(KCBGRP(I).GT.KCB.AND.KCBGRP(I).LT.KEQ) 
  158.      +                        KCBGRP(I)=KCBGRP(I)+NEQ   
  159.                            ENDIF
  160.   110                   CONTINUE
  161.                         DO 120 I=1,NEQNAM   
  162.                            IF(KEQ.LT.KCB) THEN  
  163.                               IF(KEQGRP(I).LE.KCB.AND.KEQGRP(I).GT.KEQ) 
  164.      +                        KEQGRP(I)=KEQGRP(I)-NEQ   
  165.                            ELSE 
  166.                               IF(KEQGRP(I).GT.KCB.AND.KEQGRP(I).LT.KEQ) 
  167.      +                        KEQGRP(I)=KEQGRP(I)+NEQ   
  168.                            ENDIF
  169.   120                   CONTINUE
  170.                         CALL LMERGE(SCBVAR,IWS,.FALSE.,KCBGRP(IC),NCBGRP
  171.      +                  (IC),NEQ)   
  172.                         CALL SUPMUL(SCBVAR,IWS,.FALSE.,KCBGRP(IC),  
  173.      +                  NCBGRP(IC)+NEQ,N)   
  174.                         NCBGRP(IC)=N
  175.                         NEQGRP(IE)=0
  176. *--- restart search 
  177.                         GOTO 100
  178.                      ENDIF  
  179.   130             CONTINUE  
  180.   140          CONTINUE 
  181.   150       CONTINUE
  182.          ENDIF  
  183. *--- look for any name in statement being in a c.b. 
  184.          DO 170 I=1,NSNAME  
  185.             DO 160 IC=1,NCBNAM  
  186.                CALL NAMSRC(SNAMES(ISNAME+I),SCBVAR(KCBGRP(IC)+1),NCBGRP 
  187.      +         (IC), IPOS,LAST) 
  188.                IF(IPOS.GT.0) THEN   
  189. *--- name is in this c.b. - set flag, count 
  190.                   IF(LCBVAR(KCBGRP(IC)+IPOS).EQ.0)  
  191.      +            LCBNAM(IC)=LCBNAM(IC)+1   
  192.                   LCBVAR(KCBGRP(IC)+IPOS)=LCBVAR(KCBGRP(IC)+IPOS)+1 
  193.                   GOTO 170  
  194.                ENDIF
  195.   160       CONTINUE
  196.   170    CONTINUE   
  197.       ENDIF 
  198.       GOTO 999  
  199. *--- error - name buffer overflow   
  200.   180 CONTINUE  
  201.       STATUS(12)=.TRUE. 
  202.       WRITE(MPUNIT,10000) MXNAME,SCROUT 
  203.       GOTO 999  
  204.   190 CONTINUE  
  205.       STATUS(12)=.TRUE. 
  206.       WRITE(MPUNIT,10010) MAXGRP,SCROUT 
  207.       GOTO 999  
  208.   200 CONTINUE  
  209.       STATUS(12)=.TRUE. 
  210.       WRITE(MPUNIT,10020) MAXGRP,SCROUT 
  211. 10000 FORMAT(/' +++++++++ WARNING - more than',I8,' variable names',
  212.      +' in COMMON and EQUIV., routine ',A8,' skipped')  
  213. 10010 FORMAT(/' +++++++++ WARNING - more than',I8,' common block names',
  214.      +', routine ',A8,' skipped')   
  215. 10020 FORMAT(/' +++++++++ WARNING - more than',I8,' groups',
  216.      +' in EQUIVALENCE, routine ',A8,' skipped')
  217.   999 END   
  218.